home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel0_89.lha
/
Feel
/
Modules
/
collect.em
< prev
next >
Wrap
Lisp/Scheme
|
1993-07-15
|
12KB
|
436 lines
;; Eulisp Module
;; Author: pab
;; File: collect.em
;; Date: Tue Jun 29 16:05:59 1993
;;
;; Project:
;; Description:
;; Actually, all jap's work.
(defmodule collect
(init
extras0
macros0
defs
gens
telos1
character
)
()
;; the basic collection operations
(export
accumulate
accumulate1
concatenate
do
emptyp
fill
map
size
sequencep
collectionp
)
;; not primitive, but it would be odd to omit them
(export
member
reverse
)
;; ones I had to write to make the rest work
(export
anyp
intersection
)
;; imports to be re-exported
(export
element
)
;; predicates
(defpredicate sequencep <sequence>)
(defpredicate collectionp <collection>)
;; converter methods
(defmethod (converter <list>) ((c <collection>))
;; converts any kind of collection to a list
(let ((r ()))
(labels
((loop (s)
(if (null s)
r
(progn (setq r (cons (current-element c s) r))
(loop (previous-state c s))))))
(loop (final-state c)))))
(defmethod (converter <string>) ((c <collection>))
;; converts a collection of characters to a string
(let ((r (make-string (size c))))
(labels
((loop (s1 s2)
(cond
((null s1)
r)
((characterp (current-element c s1))
((setter current-element) r s2 (current-element c s1))
(loop (next-state c s1) (next-state r s2)))
(t
(error
(format () "list(character)->string: ~a is not a character"
(current-element c s1))
<Internal-Error>)))))
(loop (initial-state c) (initial-state r)))))
(defmethod (converter <table>) ((c <collection>))
;; converts any kind of collection to a table
(let ((r (make <table>
'comparator eq
'hash-function generic-hash)))
(labels
((loop (s)
(if (null s)
r
(progn ((setter element) r (current-key c s) (current-element c s))
(loop (next-state c s))))))
(loop (initial-state c)))))
(defmethod (converter <vector>) ((c <collection>))
;; converts any kind of collection to a vector
(let ((r (make-vector (size c))))
(labels
((loop (s1 s2)
(if (null s1)
r
(progn ((setter current-element) r s2 (current-element c s1))
(loop (next-state c s1) (next-state r s2))))))
(loop (initial-state c) (initial-state r)))))
;; default methods for collections
(defmethod key-sequence ((c <collection>))
;; returns a list of integers from 0 .. size of c
(labels
((loop (i s)
(if (null s)
()
(cons i (loop (+ i 1) (next-state c s))))))
(loop 0 (initial-state c))))
(defmethod emptyp ((c <collection>)) (= 0 (size c)))
(defmethod gf-member (v (c <collection>) f)
;; returns t if the application of f to v and an element of c does
;; see list.em for a more efficient list method
(let/cc k
(gf-do
(if f
(lambda (x) (if (f v x) (k t) ()))
(lambda (x) (if (eql v x) (k t) ())))
c ())))
(defmethod gf-do (f (c <collection>) cs)
;; default method for iterating over several collections
;; simultaneously, applying the function f to the appropriate
;; combinations of elements and ignoring the result
(cond
((null cs)
;; simplest case of only one iterand
(labels
((loop-1 (s)
(if (null s)
()
(progn (f (current-element c s)) (loop-1 (next-state c s))))))
(loop-1 (initial-state c))))
((null (cdr cs))
;; two iterands
(if (or (not (sequencep c)) (not (sequencep (car cs))))
(let ((ks (intersection (key-sequence c) (key-sequence (car cs)))))
;; one or more is a table therefore have to align keys
(labels
((loop-2 (s c1 c2)
(if (null s)
()
(progn
(f (element c1 (current-element ks s))
(element c2 (current-element ks s)))
(loop-2 (next-state ks s) c1 c2)))))
(loop-2 (initial-state ks) c (car cs))))
(labels
;; only collections with natural order
((loop-2 (c1 s1 c2 s2)
(if (or (null s1) (null s2))
()
(progn
(f (current-element c1 s1) (current-element c2 s2))
(loop-2 c1 (next-state c1 s1) c2 (next-state c2 s2))))))
(loop-2 c (initial-state c) (car cs) (initial-state (car cs))))))
((anyp (lambda (x) (not (sequencep x))) (cons c cs))
;; more than two iterands
(let ((ks (apply intersection (map key-sequence (cons c cs)))))
;; and at least one is a table so align keys
(labels
((loop-n (s cs)
(if (null s)
()
(progn
(apply f
(map (lambda (c) (element c (current-element ks s))) cs))
(loop-n (next-state ks s) cs)))))
(loop-n (initial-state ks) (cons c cs)))))
(t
(labels
;; only natural order collections
((loop-n (cs ss)
(if (anyp null ss)
()
(progn
(apply f (map (lambda (c s) (current-element c s)) cs ss))
(loop-n cs (map (lambda (c s) (next-state c s)) cs ss))))))
(loop-n (cons c cs) (map initial-state (cons c cs)))))))
;; define this here temporarily until PAB does a more efficient
;; version elsewhere
(defun compose (f g) (lambda l (f (apply g l))))
(defmethod gf-any (f (c <collection>) cs)
;; default method for iterating over several collections testing the
;; appropriate combinations of elements using f. If this once
;; returns true, no further elements are processed and t is
;; returned.
(let/cc k
(apply do
(compose (lambda (x) (if x (k t) ())) f)
c cs)))
(defmethod gf-map (f (c <collection>) cs)
;; default method for iterating over several collections
;; simultaneously, applying the function f to the appropriate
;; combinations of elements and saving the result in an object of
;; the same class as c, which is returned as the result.
;; this map method only works for sequences...see table.em for one
;; which works for collections without natural order and list.em for
;; a (slightly) more efficient list version
(let ((r (clone c))
(i 0))
(apply do
(compose (lambda (x) ((setter element) r i x) (setq i (+ i 1))) f)
c cs)
r))
(defmethod accumulate (f i (c <collection>))
;; accumulates and returns the result of applying f to the initial
;; value i and the first element of c, then f to the result of that
;; and the second, and so on.
(labels
((loop-1 (a s)
(if (null s)
a
(loop-1 (f a (current-element c s)) (next-state c s)))))
(loop-1 i (initial-state c))))
(defmethod accumulate1 (f (c <collection>))
;; as accumulate except that the first value is used the initial
;; value and processing then begins with the second value.
(labels
((loop-1 (a s)
(if (null s)
a
(loop-1 (f a (current-element c s)) (next-state c s)))))
(let ((s (initial-state c)))
(if (null s)
()
(loop-1 (current-element c s) (next-state c s))))))
;; fill notes
;; ----------
;; (1) replace start and end by a collection whose elements define the
;; keys to be updated with v. Useful for objects with non-integer
;; keys, but implies need for ranges for those with integer keys.
;; (2) currently does nothing if start..end falls outside range defined
;; by 0..size. Arguably wrong behaviour for stretchy objects (tables).
;; fixed by adding a method for <table> in table.em
(defmethod fill ((mc <sequence>) v start end)
;; stores v in collection mc, starting at element position start and
;; finishing at end.
(labels
((loop (i)
(if (> i end)
()
(progn ((setter element) mc i v) (loop (+ i 1))))))
(if (and (<= 0 start) (<= start end) (< end (size mc)))
(loop start)
())))
;; concatenate notes
;; -----------------
;; (1) uses wrong key with tables...special case for tables??
;; in fact, Dylan only defines this for sequence...on tables it is
;; more like a merge, but what to do about "collisions"?
(defmethod gf-concatenate-as (class (c <sequence>) cs)
;; concatenates the elements of c and cs creating
;; an instance of class
(let* ((sizes (map size (cons c cs)))
(r (make-vector (accumulate + 0 sizes)))
(rs (initial-state r))
(fillptr 0))
(do
(lambda (c l)
(labels
((loop (s)
(if (null s)
()
(progn
((setter current-element) r rs (current-element c s))
(setq rs (next-state r rs))
(loop (next-state c s))))))
(loop (initial-state c))))
(cons c cs)
sizes)
(convert r class)))
(defmethod gf-concatenate ((c <collection>) cs)
;; see gf-concatenate-as
(gf-concatenate-as (class-of c) c cs))
(defmethod reverse ((sequence <sequence>))
;; returns a new sequence which has been initialized with the
;; elements of the argument sequence in the reverse natural order.
;; See also list.em for a more efficient list method. Works for
;; tables but doesn't mean anything...it just makes a copy.
(let* ((r (shallow-copy sequence))
(rs (final-state r)))
(do
(lambda (x)
((setter current-element) r rs x)
(setq rs (previous-state r rs)))
sequence)
r))
(defun intersection (c . cs)
;; returns a list whose elements appear in the intersection of the
;; collections c and cs. N-ary case computed by intersection of
;; first two, then intersection of subsequent collections with the
;; intersection so far.
(cond
((null cs)
c)
((null (cdr cs))
(accumulate
(lambda (a x) (if (member x c) (cons x a) a))
()
(car cs)))
(t
(accumulate
(lambda (r ci)
(accumulate
(lambda (a x) (if (member x r) (cons x a) a))
()
ci))
(accumulate
(lambda (a x) (if (member x c) (cons x a) a))
()
(car cs))
(cdr cs)))))
;; Copying protocol
(defmethod clone ((x <collection>))
(nyi "Subclass must implement clone"))
(defmethod shallow-copy ((collect <collection>))
(let ((new (clone collect))
(state (initial-state collect)))
(do (lambda (value)
((setter current-element) collect state value)
(setq state (next-state collect state)))
collect)
new))
(defmethod deep-copy ((collect <collection>))
(let ((new (clone collect))
(state (initial-state collect)))
(do (lambda (value)
((setter current-element) collect state (deep-copy value))
(setq state (next-state collect state)))
collect)
new))
)
(setq a '(0 1 2 3 4))
(setq b '#(0 1 2 3))
(setq c "012")
(setq d (make <table> 'comparator = 'hash-function generic-hash))
((setter element) d 0 'zero)
((setter element) d 1 'one)
(do print a)
(do print b)
(do print c)
(do print d)
(do (lambda (a b) (print (list a b))) a b)
(do (lambda (a b) (print (list a b))) c a)
(do (lambda (a b) (print (list a b))) a d)
(do (lambda (a b) (print (list a b))) d a)
(do (lambda (a b c) (print (list a b c))) a b c)
(do (lambda (a b c d) (print (list a b c d))) a b c d)
(defmethod select (f (c <collection>))
(labels
((loop-1 (s)
(if (null s)
()
(progn
(f (current-key c s) (current-element c s))
(loop-1 (next-state c s))))))
(loop-1 (initial-state c))))
(defgeneric accumulate-with-key (f i c))
(defmethod accumulate-with-key (f i (c <collection>))
;; accumulates and returns the result of applying f to the initial
;; value i and the first element of c, then f to the result of that
;; and the second, and so on.
(labels
((loop-1 (a s)
(if (null s)
a
(loop-1 (f a (current-key c s) (current-element c s))
(next-state c s)))))
(loop-1 i (initial-state c))))
(defgeneric copy-sequence (s i j))
(export copy-sequence)
(defmethod copy-sequence ((s <sequence>) start end)
(let/cc k
(accumulate-with-key
(lambda (a key value)
(format t "a, key, value = ~a, ~a, ~a~%" a key value)
(cond
((< key start) a)
((<= key end) (cons value a))
(t (k (reverse a)))))
()
s)))
(defmethod fill ((s <sequence>) v start end)
(let/cc k
(accumulate-with-key
(lambda (a key value)
(format t "a, key, value = ~a, ~a, ~a~%" a key value)
(cond
((< key start) ())
((<= key end) ((setter element) s key v))
(t (k ()))))
()
s)))